Acorn RISC PD-CD 1

home *** CD-ROM | disk | FTP | other *** search

/ Acorn RISC PD-CD 1 / Acorn RISC PD-CD 1.iso / languages / dde / _pascals / p / pascals

Wrap

Text File | 1992-02-27 | 93.2 KB | 3,419 lines

PROGRAM PASCALS(INPUT , OUTPUT); LABEL 99; CONST MAXKEYWORDS = 27; ALPHALENGTH = 10; LINELENGTH = 120; EMAX = 322; EMIN = - 99; KMAX = 15; TMAX = 100; BMAX = 20; AMAX = 30; C2MAX = 20; CSMAX = 30; CMAX = 850; LMAX = 7; SMAX = 600; ERMAX = 58; OMAX = 63; XMAX = 131071; NMAX = MAXINT; LINELENG = 136; LINELIMIT = 200; STACKSIZE = 1500; TYPE SYMBOL = (INTCON, REALCON, CHARCON, STRING, NOTSY, PLUS, MINUS, TIMES, IDIV, RDIV, IMOD, ANDSY, ORSY, EQL, NEQ, GTR, GEQ, LSS, LEQ, LPARENT, RPARENT, LBRACK, RBRACK, COMMA, SEMICOLON, PERIOD, COLON, BECOMES, CONSTSY, TYPESY, VARSY, FUNCTIONSY, PROCEDURESY, ARRAYSY, RECORDSY , PROGRAMSY, IDENT, BEGINSY, IFSY, CASESY, REPEATSY, WHILESY, FORSY, ENDSY, ELSESY, UNTILSY, OFSY, DOSY, TOSY, DOWNTOSY, THENSY) ; INDEX = - XMAX .. + XMAX; ALFA = PACKED ARRAY [1.. ALPHALENGTH] OF CHAR; OBJECT = (KONSTANT, VARIABLE, TYPE1, PROZEDURE, FUNKTION); TYPES = (NOTYP, INTS, REALS, BOOLS, CHARS, ARRAYS, RECORDS); SYMSET = SET OF SYMBOL; TYPSET = SET OF TYPES; ITEM = RECORD TYP: TYPES; IREF: INDEX END; ORDER = RECORD F: 0 .. + OMAX; X: 0 .. + LMAX; Y: - NMAX .. + NMAX END; VAR SY: SYMBOL; ID: ALFA; INUM: INTEGER; RNUM: REAL; SLENG: INTEGER; CH: CHAR; LINE: ARRAY [1 .. LINELENGTH] OF CHAR; CC: INTEGER; LC: INTEGER; LL: INTEGER; ERRS: SET OF 0 .. ERMAX; ERRPOS: INTEGER; PROGNAME: ALFA; IFLAG: BOOLEAN; OFLAG: BOOLEAN; CONSTBEGSYS, TYPEBEGSYS, BLOCKBEGSYS, FACBEGSYS, STATBEGSYS: SYMSET; KEY: ARRAY [1 .. MAXKEYWORDS] OF ALFA; KSY: ARRAY [1 .. MAXKEYWORDS] OF SYMBOL; SPS: ARRAY [CHAR] OF SYMBOL; T, A, B, SX, C1, C2: INTEGER; STANTYPS: TYPSET; DISPLAY: ARRAY [0 .. LMAX] OF INTEGER; TAB: ARRAY [0 .. TMAX] OF PACKED RECORD NAME: ALFA; LINK: INDEX; OBJ: OBJECT; TYP: TYPES; IREF: INDEX; NORMAL: BOOLEAN; LEV: 0 .. LMAX; ADR: INTEGER END; ATAB: ARRAY [1 .. AMAX] OF PACKED RECORD INXTYP, ELTYP: TYPES; ELIREF, LOW, HIGH, ELSIZE, SIZE: INDEX; END; BTAB: ARRAY [1 .. BMAX] OF PACKED RECORD LAST, LASTPAR, PSIZE, VSIZE: INDEX END; STAB: PACKED ARRAY [0 .. SMAX] OF CHAR; RCONST: ARRAY [1 .. C2MAX] OF REAL; CODE: ARRAY [0 .. CMAX] OF ORDER; PROCEDURE ERRORMSG; VAR K: INTEGER; MSG: ARRAY [0 .. ERMAX] OF ALFA; BEGIN MSG[0] := 'UNDEF ID '; MSG[1] := 'MULTI DEF '; MSG[2] := 'IDENTIFIER'; MSG[3] := 'PROGRAM '; MSG[4] := ') '; MSG[5] := ': '; MSG[6] := 'SYNTAX '; MSG[7] := 'IDENT, VAR'; MSG[8] := 'OF '; MSG[9] := '( '; MSG[10] := 'ID, ARRAY '; MSG[11] := '[ '; MSG[12] := '] '; MSG[13] := '.. '; MSG[14] := '; '; MSG[15] := 'FUNC. TYPE'; MSG[16] := '= '; MSG[17] := 'BOOLEAN '; MSG[18] := 'CONVAR TYP'; MSG[19] := 'TYPE '; MSG[20] := 'PROG.PARAM'; MSG[21] := 'TOO BIG '; MSG[22] := '. '; MSG[23] := 'TYP (CASE)'; MSG[24] := 'CHARACTER '; MSG[25] := 'CONST ID '; MSG[26] := 'INDEX TYPE'; MSG[27] := 'INDEXBOUND'; MSG[28] := 'NO ARRAY '; MSG[29] := 'TYPE ID '; MSG[30] := 'UNDEF TYPE'; MSG[31] := 'NO RECORD '; MSG[32] := 'BOOLE TYPE'; MSG[33] := 'ARITH TYPE'; MSG[34] := 'INTEGER '; MSG[35] := 'TYPES '; MSG[36] := 'PARAM TYPE'; MSG[37] := 'VARIAB TYP'; MSG[38] := 'STRING '; MSG[39] := 'NO.OF PARS'; MSG[40] := 'TYPE '; MSG[41] := 'TYPE '; MSG[42] := 'REAL TYPE '; MSG[43] := 'INTEGER '; MSG[44] := 'VAR, CONST'; MSG[45] := 'VAR, PROC '; MSG[46] := 'TYPES (:=)'; MSG[47] := 'TYP (CASE)'; MSG[48] := 'TYPE '; MSG[49] := 'STORE OVFL'; MSG[50] := 'CONSTANT '; MSG[51] := ':= '; MSG[52] := 'THEN '; MSG[53] := 'UNTIL '; MSG[54] := 'DO '; MSG[55] := 'TO DOWNTO '; MSG[56] := 'BEGIN '; MSG[57] := 'END '; MSG[58] := 'FACTOR '; K := 0; WRITELN; WRITELN(' KEY WORDS'); WHILE ERRS <> [] DO BEGIN WHILE NOT (K IN ERRS) DO K := K + 1; WRITELN(K, ' ', MSG[K]); ERRS := ERRS - [K] END (*WHILE*) END (*ERRORMSG*); PROCEDURE NEXTCH; (* READ THE NEXT CHARACTER AND THE END OF LINES *) BEGIN IF CC = LL THEN BEGIN IF EOF(INPUT) THEN BEGIN WRITELN; WRITELN(' PROGRAM INCOMPLETE.'); ERRORMSG; GOTO 99 END (*IF*); IF ERRPOS <> 0 THEN BEGIN WRITELN; ERRPOS := 0 END (*IF*); WRITE(LC: 5, ' '); LL := 0; CC := 0; WHILE NOT EOLN(INPUT) DO BEGIN LL := LL + 1; READ(CH); WRITE(CH); LINE[LL] := CH END (*WHILE*); WRITELN; LL := LL + 1; READ(LINE[LL]) END (*IF*); CC := CC + 1; CH := LINE[CC] END (*NEXTCH*); PROCEDURE ERROR(N: INTEGER); BEGIN IF ERRPOS = 0 THEN WRITE(' ****'); IF CC > ERRPOS THEN BEGIN WRITE(' ': CC - ERRPOS, '@', N: 2); ERRPOS := CC + 3; ERRS := ERRS + [N] END (*IF*) END (*ERROR*); PROCEDURE FATAL(N: INTEGER); VAR MSG: ARRAY [1 .. 7] OF ALFA; BEGIN WRITELN; ERRORMSG; MSG[1] := 'IDENTIFIER'; MSG[2] := 'PROCEDURES'; MSG[3] := 'REALS '; MSG[4] := 'ARRAYS '; MSG[5] := 'LEVELS '; MSG[6] := 'CODE '; MSG[7] := 'STRINGS '; WRITELN(' COMPILER TABLE FOR ', MSG[N], ' IS TOO SMALL'); GOTO 99 (* TERMINATE COMPILATION *); END (*FATAL*); PROCEDURE INSYMBOL; (* READS NEXT SYMBOL *) LABEL 1, 2, 3; VAR I, J, K, E: INTEGER; PROCEDURE READSCALE; VAR S, SIGN: INTEGER; BEGIN NEXTCH; SIGN := 1; S := 0; IF CH = '+' THEN NEXTCH ELSE IF CH = '-' THEN BEGIN NEXTCH; SIGN := - 1; END (*IF*); WHILE CH IN ['0' .. '9'] DO BEGIN S := 10 * S + ORD(CH) - ORD('0'); NEXTCH END (*WHILE*); E := S * SIGN + E END (*READSCALE*); PROCEDURE ADJUSTSCALE; VAR S: INTEGER; D, T: REAL; BEGIN IF K + E > EMAX THEN ERROR(21) ELSE IF K + E < EMIN THEN RNUM := 0 ELSE BEGIN S := ABS(E); T := 1.0; D := 10.0; REPEAT WHILE NOT ODD(S) DO BEGIN S := S DIV 2; D := SQR(D) END (*WHILE*); S := S - 1; T := D * T UNTIL S = 0; IF E >= 0 THEN RNUM := RNUM * T ELSE RNUM := RNUM / T END (*ELSE*) END (*ADJUSTSCALE*); BEGIN (*INSYMBOL*) 1: WHILE CH = ' ' DO NEXTCH; IF CH IN ['A' .. 'Z'] THEN BEGIN (*WORD*) K := 0; ID := ' '; REPEAT IF K < ALPHALENGTH THEN BEGIN K := K + 1; ID[K] := CH END (*IF*); NEXTCH UNTIL NOT (CH IN ['A' .. 'Z', '0' .. '9']); I := 1; J := MAXKEYWORDS; (* BINARY SEARCH *) REPEAT K := (I + J) DIV 2; IF ID <= KEY[K] THEN J := K - 1; IF ID >= KEY[K] THEN I := K + 1 UNTIL I > J; IF I - 1 > J THEN SY := KSY[K] ELSE SY := IDENT END (*IF*) ELSE IF CH IN ['0' .. '9'] THEN BEGIN (* NUMBER *) K := 0; INUM := 0; SY := INTCON; REPEAT INUM := INUM * 10 + ORD(CH) - ORD('0'); K := K + 1; NEXTCH UNTIL NOT (CH IN ['0' .. '9']); IF (K > KMAX) OR (INUM > NMAX) THEN BEGIN ERROR(21); INUM := 0; K := 0 END (*IF*); IF CH = '.' THEN BEGIN NEXTCH; IF CH = '.' THEN CH := ':' ELSE BEGIN SY := REALCON; RNUM := INUM; E := 0; WHILE CH IN ['0' .. '9'] DO BEGIN E := E - 1; RNUM := 10.0 * RNUM + (ORD(CH) - ORD('0')); NEXTCH END (*WHILE*); IF CH = 'E' THEN READSCALE; IF E <> 0 THEN ADJUSTSCALE END (*ELSE*) END (*IF*) ELSE IF CH = 'E' THEN BEGIN SY := REALCON; RNUM := INUM; E := 0; READSCALE; IF E <> 0 THEN ADJUSTSCALE END (*IF*) END (*IF*) ELSE CASE CH OF ':': BEGIN NEXTCH; IF CH = '=' THEN BEGIN SY := BECOMES; NEXTCH END (*IF*) ELSE SY := COLON END (*':'*); '<': BEGIN NEXTCH; IF CH = '=' THEN BEGIN SY := LEQ; NEXTCH END (*IF*) ELSE IF CH = '>' THEN BEGIN SY := NEQ; NEXTCH END (*IF*) ELSE SY := LSS END (*'<'*); '>': BEGIN NEXTCH; IF CH = '=' THEN BEGIN SY := GEQ; NEXTCH END (*IF*) ELSE SY := GTR END (*'>'*); '.': BEGIN NEXTCH; IF CH = '.' THEN BEGIN SY := COLON; NEXTCH END (*IF*) ELSE SY := PERIOD END (*'.'*); '''': BEGIN K := 0; 2: NEXTCH; IF CH = '''' THEN BEGIN NEXTCH; IF CH <> '''' THEN GOTO 3 END (*IF*); IF SX + K = SMAX THEN FATAL(7); STAB[SX + K] := CH; K := K + 1; IF CC = 1 THEN BEGIN (* END OF LINE *) K := 0 END (*IF*) ELSE GOTO 2; 3: IF K = 1 THEN BEGIN SY := CHARCON; INUM := ORD(STAB[SX]) END (*IF*) ELSE IF K = 0 THEN BEGIN ERROR(38); SY := CHARCON; INUM := 0 END (*IF*) ELSE BEGIN SY := STRING; INUM := SX; SLENG := K; SX := SX + K END (*ELSE*) END (*''''*); '(': BEGIN NEXTCH; IF CH <> '*' THEN SY := LPARENT ELSE BEGIN (* COMMENT *) REPEAT WHILE CH <> '*' DO NEXTCH; NEXTCH; UNTIL CH = ')'; NEXTCH; GOTO 1 END (*ELSE*) END (*'('*); '+', '-', '*', '/', ')', '=', ',', '[', ']', '#', '&', ';': BEGIN SY := SPS[CH]; NEXTCH END (*'+'*); '\', '%', '@', '$', '!': BEGIN ERROR(24); NEXTCH; GOTO 1 END (*'\'*) END (*CASE*) END (*INSYMBOL*); PROCEDURE ENTER(X0: ALFA; X1: OBJECT; X2: TYPES; X3: INTEGER); BEGIN (* ENTER STANDARD IDENTIFIER *) T := T + 1; WITH TAB[T] DO BEGIN NAME := X0; LINK := T - 1; OBJ := X1; TYP := X2; IREF := 0; NORMAL := TRUE; LEV := 0; ADR := X3 END (*WITH*) END (*ENTER*); PROCEDURE ENTERARRAY(TP: TYPES; L, H: INTEGER); BEGIN IF L > H THEN ERROR(27); IF (ABS(L) > XMAX) OR (ABS(H) > XMAX) THEN BEGIN ERROR(27); L := 0; H := 0 END (*IF*); IF A = AMAX THEN FATAL(4) ELSE BEGIN A := A + 1; WITH ATAB[A] DO BEGIN INXTYP := TP; LOW := L; HIGH := H END (*WITH*) END (*ELSE*) END (*ENTERARRAY*); PROCEDURE ENTERBLOCK; BEGIN IF B = BMAX THEN FATAL(2) ELSE BEGIN B := B + 1; BTAB[B].LAST := 0; BTAB[B].LASTPAR := 0; END (*ELSE*) END (*ENTERBLOCK*); PROCEDURE ENTERREAL(X: REAL); BEGIN IF C2 = C2MAX - 1 THEN FATAL(3) ELSE BEGIN RCONST[C2 + 1] := X; C1 := 1; WHILE RCONST[C1] <> X DO C1 := C1 + 1; IF C1 > C2 THEN C2 := C1 END (*ELSE*) END (*ENTERREAL*); PROCEDURE EMIT(FCT: INTEGER); BEGIN IF LC = CMAX THEN FATAL(6); CODE[LC].F := FCT; LC := LC + 1 END (*EMIT*); PROCEDURE EMIT1(FCT, B: INTEGER); BEGIN IF LC = CMAX THEN FATAL(6); WITH CODE[LC] DO BEGIN F := FCT; Y := B END (*WITH*); LC := LC + 1 END (*EMIT1*); PROCEDURE EMIT2(FCT, A, B: INTEGER); BEGIN IF LC = CMAX THEN FATAL(6); WITH CODE[LC] DO BEGIN F := FCT; X := A; Y := B END (*WITH*); LC := LC + 1 END (*EMIT2*); PROCEDURE PRINTTABLES; VAR I: INTEGER; O: ORDER; BEGIN WRITELN('0IDENTIFIERS LINK OBJ TYP IREF NRM LEV ADR'); FOR I := BTAB[1].LAST + 1 TO T DO WITH TAB[I] DO WRITELN(I, ' ', NAME, LINK: 5, ORD(OBJ): 5, ORD(TYP): 5, IREF: 5, ORD( NORMAL): 5, LEV: 5, ADR: 5); WRITELN('0BLOCKS LAST LPAR PSZE VSZE'); FOR I := 1 TO B DO WITH BTAB[I] DO WRITELN(I, LAST: 5, LASTPAR: 5, PSIZE: 5, VSIZE: 5); WRITELN('0ARRAYS XTYP ETYP EIREF LOW HIGH ELSZ SIZE'); FOR I := 1 TO A DO WITH ATAB[I] DO WRITELN(I, ORD(INXTYP): 5, ORD(ELTYP): 5, ELIREF: 5, LOW: 5, HIGH: 5, ELSIZE: 5, SIZE: 5); WRITELN('0CODE'); FOR I := 0 TO LC - 1 DO BEGIN IF I MOD 5 = 0 THEN BEGIN WRITELN; WRITE(I: 5) END (*IF*); O := CODE[I]; WRITE(O.F: 5); IF O.F < 31 THEN IF O.F < 4 THEN WRITE(O.X: 2, O.Y: 5) ELSE WRITE(O.Y: 7) ELSE WRITE(' '); WRITE(',') END (*FOR*); WRITELN; END (*PRINTTABLES*); PROCEDURE BLOCK(FSYS: SYMSET; ISFUN: BOOLEAN; LEVEL: INTEGER); TYPE CONREC = RECORD CASE TP: TYPES OF INTS, CHARS, BOOLS: ( I: INTEGER); REALS: ( R: REAL) END; VAR DX, (* DATA ALLOCATION INDEX *) PRT, (* T-INDEX OF THIS PROCEDURE *) PRB, (* B-INDEX OF THIS PROCEDURE *) X: INTEGER; PROCEDURE SKIP(FSYS: SYMSET; N: INTEGER); BEGIN ERROR(N); WHILE NOT (SY IN FSYS) DO INSYMBOL END (*SKIP*); PROCEDURE TEST(S1, S2: SYMSET; N: INTEGER); BEGIN IF NOT (SY IN S1) THEN SKIP(S1 + S2, N) END (*TEST*); PROCEDURE TESTSEMICOLON; BEGIN IF SY = SEMICOLON THEN INSYMBOL ELSE BEGIN ERROR(14); IF SY IN [COMMA, COLON] THEN INSYMBOL END (*ELSE*); TEST([IDENT] + BLOCKBEGSYS, FSYS, 6) END (*TESTSEMICOLON*); PROCEDURE ENTER(ID: ALFA; K: OBJECT); VAR J, L: INTEGER; BEGIN IF T = TMAX THEN FATAL(1) ELSE BEGIN TAB[0].NAME := ID; J := BTAB[DISPLAY[LEVEL]].LAST; L := J; WHILE TAB[J].NAME <> ID DO J := TAB[J].LINK; IF J <> 0 THEN ERROR(1) ELSE BEGIN T := T + 1; WITH TAB[T] DO BEGIN NAME := ID; LINK := L; OBJ := K; TYP := NOTYP; IREF := 0; LEV := LEVEL; ADR := 0 END (*WITH*); BTAB[DISPLAY[LEVEL]].LAST := T END (*ELSE*) END (*ELSE*) END (*ENTER*); FUNCTION LOC(ID: ALFA): INTEGER; VAR I, J: INTEGER; (* LOCATE ID IN TABLE *) BEGIN I := LEVEL; TAB[0].NAME := ID; REPEAT J := BTAB[DISPLAY[I]].LAST; WHILE TAB[J].NAME <> ID DO J := TAB[J].LINK; I := I - 1 UNTIL (I < 0) OR (J <> 0); IF J = 0 THEN ERROR(0); LOC := J END (*LOC*); PROCEDURE ENTERVARIABLE; BEGIN IF SY = IDENT THEN BEGIN ENTER(ID, VARIABLE); INSYMBOL END (*IF*) ELSE ERROR(2) END (*ENTERVARIABLE*); PROCEDURE CONSTANT(FSYS: SYMSET; VAR C: CONREC); VAR X, SIGN: INTEGER; BEGIN C.TP := NOTYP; C.I := 0; TEST(CONSTBEGSYS, FSYS, 50); IF SY IN CONSTBEGSYS THEN BEGIN IF SY = CHARCON THEN BEGIN C.TP := CHARS; C.I := INUM; INSYMBOL END (*IF*) ELSE BEGIN SIGN := 1; IF SY IN [PLUS, MINUS] THEN BEGIN IF SY = MINUS THEN SIGN := - 1; INSYMBOL END (*IF*); IF SY = IDENT THEN BEGIN X := LOC(ID); IF X <> 0 THEN IF TAB[X].OBJ <> KONSTANT THEN ERROR(25) ELSE BEGIN C.TP := TAB[X].TYP; IF C.TP = REALS THEN C.R := SIGN * RCONST[TAB[X].ADR] ELSE C.I := SIGN * TAB[X].ADR END (*ELSE*); INSYMBOL END (*IF*) ELSE IF SY = INTCON THEN BEGIN C.TP := INTS; C.I := SIGN * INUM; INSYMBOL END (*IF*) ELSE IF SY = REALCON THEN BEGIN C.TP := REALS; C.R := SIGN * RNUM; INSYMBOL END (*IF*) ELSE SKIP(FSYS, 50) END (*ELSE*); TEST(FSYS, [], 6) END (*IF*) END (*CONSTANT*); PROCEDURE TYP(FSYS: SYMSET; VAR TP: TYPES; VAR RF, SZ: INTEGER); VAR X: INTEGER; ELTP: TYPES; ELRF: INTEGER; ELSZ, OFFSET, T0, T1: INTEGER; PROCEDURE ARRAYTYP(VAR AIREF, ARSZ: INTEGER); VAR ELTP: TYPES; LOW, HIGH: CONREC; ELRF, ELSZ: INTEGER; BEGIN CONSTANT([COLON, RBRACK, RPARENT, OFSY] + FSYS, LOW); IF LOW.TP = REALS THEN BEGIN ERROR(27); LOW.TP := INTS; LOW.I := 0 END (*IF*); IF SY = COLON THEN INSYMBOL ELSE ERROR(13); CONSTANT([RBRACK, COMMA, RPARENT, OFSY] + FSYS, HIGH); IF HIGH.TP <> LOW.TP THEN BEGIN ERROR(27); HIGH.I := LOW.I END (*IF*); ENTERARRAY(LOW.TP, LOW.I, HIGH.I); AIREF := A; IF SY = COMMA THEN BEGIN INSYMBOL; ELTP := ARRAYS; ARRAYTYP(ELRF, ELSZ) END (*IF*) ELSE BEGIN IF SY = RBRACK THEN INSYMBOL ELSE BEGIN ERROR(12); IF SY = RPARENT THEN INSYMBOL END (*ELSE*); IF SY = OFSY THEN INSYMBOL ELSE ERROR(8); TYP(FSYS, ELTP, ELRF, ELSZ) END (*ELSE*); WITH ATAB[AIREF] DO BEGIN ARSZ := (HIGH - LOW + 1) * ELSZ; SIZE := ARSZ; ELTYP := ELTP; ELIREF := ELRF; ELSIZE := ELSZ END (*WITH*) END (*ARRAYTYP*); BEGIN (*TYP*) TP := NOTYP; RF := 0; SZ := 0; TEST(TYPEBEGSYS, FSYS, 10); IF SY IN TYPEBEGSYS THEN BEGIN IF SY = IDENT THEN BEGIN X := LOC(ID); IF X <> 0 THEN WITH TAB[X] DO IF OBJ <> TYPE1 THEN ERROR(29) ELSE BEGIN TP := TYP; RF := IREF; SZ := ADR; IF TP = NOTYP THEN ERROR(30) END (*ELSE*); INSYMBOL END (*IF*) ELSE IF SY = ARRAYSY THEN BEGIN INSYMBOL; IF SY = LBRACK THEN INSYMBOL ELSE BEGIN ERROR(11); IF SY = LPARENT THEN INSYMBOL END (*ELSE*); TP := ARRAYS; ARRAYTYP(RF, SZ) END (*IF*) ELSE BEGIN (*RECORDS*) INSYMBOL; ENTERBLOCK; TP := RECORDS; RF := B; IF LEVEL = LMAX THEN FATAL(5); LEVEL := LEVEL + 1; DISPLAY[LEVEL] := B; OFFSET := 0; WHILE SY <> ENDSY DO BEGIN (* FIELD SECXTION *) IF SY = IDENT THEN BEGIN T0 := T; ENTERVARIABLE; WHILE SY = COMMA DO BEGIN INSYMBOL; ENTERVARIABLE END (*WHILE*); IF SY = COLON THEN INSYMBOL ELSE ERROR(5); T1 := T; TYP(FSYS + [SEMICOLON, ENDSY, COMMA, IDENT], ELTP, ELRF, ELSZ); WHILE T0 < T1 DO BEGIN T0 := T0 + 1; WITH TAB[T0] DO BEGIN TYP := ELTP; IREF := ELRF; NORMAL := TRUE; ADR := OFFSET; OFFSET := OFFSET + ELSZ END (*WITH*) END (*WHILE*) END (*IF*); IF SY <> ENDSY THEN BEGIN IF SY = SEMICOLON THEN INSYMBOL ELSE BEGIN ERROR(14); IF SY = COMMA THEN INSYMBOL END (*ELSE*); TEST([IDENT, ENDSY, SEMICOLON], FSYS, 6) END (*IF*); END (*WHILE*); BTAB[RF].VSIZE := OFFSET; SZ := OFFSET; BTAB[RF].PSIZE := 0; INSYMBOL; LEVEL := LEVEL - 1 END (*ELSE*); TEST(FSYS, [], 6) END (*IF*) END (*TYP*); PROCEDURE PARAMETERLIST; (* FORMAL PARAMETER LIST *) VAR TP: TYPES; RF, SZ, X, T0: INTEGER; VALPAR: BOOLEAN; BEGIN INSYMBOL; TP := NOTYP; RF := 0; SZ := 0; TEST([IDENT, VARSY], FSYS + [RPARENT], 7); WHILE SY IN [IDENT, VARSY] DO BEGIN IF SY <> VARSY THEN VALPAR := TRUE ELSE BEGIN INSYMBOL; VALPAR := FALSE END (*ELSE*); T0 := T; ENTERVARIABLE; WHILE SY = COMMA DO BEGIN INSYMBOL; ENTERVARIABLE END (*WHILE*); IF SY = COLON THEN BEGIN INSYMBOL; IF SY <> IDENT THEN ERROR(2) ELSE BEGIN X := LOC(ID); INSYMBOL; IF X <> 0 THEN WITH TAB[X] DO IF OBJ <> TYPE1 THEN ERROR(29) ELSE BEGIN TP := TYP; RF := IREF; IF VALPAR THEN SZ := ADR ELSE SZ := 1; END (*ELSE*); END (*ELSE*); TEST([SEMICOLON, RPARENT], [COMMA, IDENT] + FSYS, 14); END (*IF*) ELSE ERROR(5); WHILE T0 < T DO BEGIN T0 := T0 + 1; WITH TAB[T0] DO BEGIN TYP := TP; IREF := RF; NORMAL := VALPAR; ADR := DX; LEV := LEVEL; DX := DX + SZ END (*WITH*) END (*WHILE*); IF SY <> RPARENT THEN BEGIN IF SY = SEMICOLON THEN INSYMBOL ELSE BEGIN ERROR(14); IF SY = COMMA THEN INSYMBOL END (*ELSE*); TEST([IDENT, VARSY], [RPARENT] + FSYS, 6) END (*IF*) END (*WHILE*); IF SY = RPARENT THEN BEGIN INSYMBOL; TEST([SEMICOLON, COLON], FSYS, 6) END (*IF*) ELSE ERROR(4) END (*PARAMETERLIST*); PROCEDURE CONSTANTDECLARATION; VAR C: CONREC; BEGIN INSYMBOL; TEST([IDENT], BLOCKBEGSYS, 2); WHILE SY = IDENT DO BEGIN ENTER(ID, KONSTANT); INSYMBOL; IF SY = EQL THEN INSYMBOL ELSE BEGIN IF SY = BECOMES THEN INSYMBOL END (*ELSE*); CONSTANT([SEMICOLON, COMMA, IDENT] + FSYS, C); TAB[T].TYP := C.TP; TAB[T].IREF := 0; IF C.TP = REALS THEN BEGIN ENTERREAL(C.R); TAB[T].ADR := C1 END (*IF*) ELSE TAB[T].ADR := C.I; TESTSEMICOLON END (*WHILE*) END (*CONSTANTDECLARATION*); PROCEDURE TYPEDECLARATION; VAR TP: TYPES; RF, SZ, T1: INTEGER; BEGIN INSYMBOL; TEST([IDENT], BLOCKBEGSYS, 2); WHILE SY = IDENT DO BEGIN ENTER(ID, TYPE1); T1 := T; INSYMBOL; IF SY = EQL THEN INSYMBOL ELSE BEGIN ERROR(16); IF SY = BECOMES THEN INSYMBOL END (*ELSE*); TYP([SEMICOLON, COMMA, IDENT] + FSYS, TP, RF, SZ); WITH TAB[T1] DO BEGIN TYP := TP; IREF := RF; ADR := SZ END (*WITH*); TESTSEMICOLON; END (*WHILE*) END (*TYPEDECLARATION*); PROCEDURE VARIABLEDECLARATION; VAR T0, T1, RF, SZ: INTEGER; TP: TYPES; BEGIN INSYMBOL; WHILE SY = IDENT DO BEGIN T0 := T; ENTERVARIABLE; WHILE SY = COMMA DO BEGIN INSYMBOL; ENTERVARIABLE; END (*WHILE*); IF SY = COLON THEN INSYMBOL ELSE ERROR(5); T1 := T; TYP([SEMICOLON, COMMA, IDENT] + FSYS, TP, RF, SZ); WHILE T0 < T1 DO BEGIN T0 := T0 + 1; WITH TAB[T0] DO BEGIN TYP := TP; IREF := RF; LEV := LEVEL; ADR := DX; NORMAL := TRUE; DX := DX + SZ END (*WITH*) END (*WHILE*); TESTSEMICOLON END (*WHILE*) END (*VARIABLEDECLARATION*); PROCEDURE PROCDECLARATION; VAR ISFUN: BOOLEAN; BEGIN ISFUN := SY = FUNCTIONSY; INSYMBOL; IF SY <> IDENT THEN BEGIN ERROR(2); ID := ' '; END (*IF*); IF ISFUN THEN ENTER(ID, FUNKTION) ELSE ENTER(ID, PROZEDURE); TAB[T].NORMAL := TRUE; INSYMBOL; BLOCK([SEMICOLON] + FSYS, ISFUN, LEVEL + 1); IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14); EMIT(32 + ORD(ISFUN)) (*EXIT*) END (*PROCDECLARATION*); PROCEDURE STATEMENT(FSYS: SYMSET); VAR I: INTEGER; X: ITEM; PROCEDURE EXPRESSION(FSYS: SYMSET; VAR X: ITEM); FORWARD; PROCEDURE SELECTOR(FSYS: SYMSET; VAR V: ITEM); VAR S: ITEM; A, J: INTEGER; BEGIN (* SY IN [LPARENT,LBRACK,PERIOD] *) REPEAT IF SY = PERIOD THEN BEGIN (* FIELD SELECTOR *) INSYMBOL; IF SY <> IDENT THEN ERROR(2) ELSE BEGIN IF V.TYP <> RECORDS THEN ERROR(31) ELSE BEGIN (* SEARCH FIELD IDENTIFIER *) J := BTAB[V.IREF].LAST; TAB[0].NAME := ID; WHILE TAB[J].NAME <> ID DO J := TAB[J].LINK; IF J = 0 THEN ERROR(0); V.TYP := TAB[J].TYP; V.IREF := TAB[J].IREF; A := TAB[J].ADR; IF A <> 0 THEN EMIT1(9, A) END (*ELSE*); INSYMBOL END (*ELSE*) END (*IF*) ELSE BEGIN (* ARRAY SELECTOR *) IF SY <> LBRACK THEN ERROR(11); REPEAT INSYMBOL; EXPRESSION(FSYS + [COMMA, RBRACK], X); IF V.TYP <> ARRAYS THEN ERROR(28) ELSE BEGIN A := V.IREF; IF ATAB[A].INXTYP <> X.TYP THEN ERROR(26) ELSE IF ATAB[A].ELSIZE = 1 THEN EMIT1(20, A) ELSE EMIT1(21, A); V.TYP := ATAB[A].ELTYP; V.IREF := ATAB[A].ELIREF END (*ELSE*) UNTIL SY <> COMMA; IF SY = RBRACK THEN INSYMBOL ELSE BEGIN ERROR(12); IF SY = RPARENT THEN INSYMBOL END (*ELSE*) END (*ELSE*) UNTIL NOT (SY IN [LBRACK, LPARENT, PERIOD]); TEST(FSYS, [], 6) END (*SELECTOR*); PROCEDURE CALL(FSYS: SYMSET; I: INTEGER); VAR X: ITEM; LASTP, CP, K: INTEGER; BEGIN EMIT1(18, I) (* MARK STACK *); LASTP := BTAB[TAB[I].IREF].LASTPAR; CP := I; IF SY = LPARENT THEN BEGIN (* ACTUAL PARAMETER LIST *) REPEAT INSYMBOL; IF CP >= LASTP THEN ERROR(39) ELSE BEGIN CP := CP + 1; IF TAB[CP].NORMAL THEN BEGIN (* VALUE PARAMETER *) EXPRESSION(FSYS + [COMMA, COLON, RPARENT], X); IF X.TYP = TAB[CP].TYP THEN BEGIN IF X.IREF <> TAB[CP].IREF THEN ERROR(36) ELSE IF X.TYP = ARRAYS THEN EMIT1(22, ATAB[X.IREF].SIZE) ELSE IF X.TYP = RECORDS THEN EMIT1(22, BTAB[X.IREF].VSIZE) END (*IF*) ELSE IF (X.TYP = INTS) AND (TAB[CP].TYP = REALS) THEN EMIT1(26, 0) ELSE IF X.TYP <> NOTYP THEN ERROR(36); END (*IF*) ELSE BEGIN (* VARAIABLE PARAMETER *) IF SY <> IDENT THEN ERROR(2) ELSE BEGIN K := LOC(ID); INSYMBOL; IF K <> 0 THEN BEGIN IF TAB[K].OBJ <> VARIABLE THEN ERROR(37); X.TYP := TAB[K].TYP; X.IREF := TAB[K].IREF; IF TAB[K].NORMAL THEN EMIT2(0, TAB[K].LEV, TAB[K].ADR) ELSE EMIT2(1, TAB[K].LEV, TAB[K].ADR); IF SY IN [LBRACK, LPARENT, PERIOD] THEN SELECTOR(FSYS + [COMMA, COLON, RPARENT], X); IF (X.TYP <> TAB[CP].TYP) OR (X.IREF <> TAB[CP .). IREF) THEN ERROR(36) END (*IF*) END (*ELSE*) END (*ELSE*) END (*ELSE*); TEST([COMMA, RPARENT], FSYS, 6) UNTIL SY <> COMMA; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END (*IF*); IF CP < LASTP THEN ERROR(39); (* TOO FEW ACTUAL PARAMETERS *) EMIT1(19, BTAB[TAB[I].IREF].PSIZE - 1); IF TAB[I].LEV < LEVEL THEN EMIT2(3, TAB[I].LEV, LEVEL) END (*CALL*); FUNCTION RESULTTYPE(A, B: TYPES): TYPES; BEGIN IF (A > REALS) OR (B > REALS) THEN BEGIN ERROR(33); RESULTTYPE := NOTYP END (*IF*) ELSE IF (A = NOTYP) OR (B = NOTYP) THEN RESULTTYPE := NOTYP ELSE IF A = INTS THEN IF B = INTS THEN RESULTTYPE := INTS ELSE BEGIN RESULTTYPE := REALS; EMIT1(26, 1) END (*ELSE*) ELSE BEGIN RESULTTYPE := REALS; IF B = INTS THEN EMIT1(26, 0) END (*ELSE*) END (*RESULTTYPE*); PROCEDURE EXPRESSION; VAR Y: ITEM; OP: SYMBOL; PROCEDURE SIMPLEEXPRESSION(FSYS: SYMSET; VAR X: ITEM); VAR Y: ITEM; OP: SYMBOL; PROCEDURE TERM(FSYS: SYMSET; VAR X: ITEM); VAR Y: ITEM; OP: SYMBOL; TS: TYPSET; PROCEDURE FACTOR(FSYS: SYMSET; VAR X: ITEM); VAR I, F: INTEGER; PROCEDURE STANDFCT(N: INTEGER); VAR TS: TYPSET; BEGIN (* STANDARD FUNCTION NUMBER N *) IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9); IF N < 17 THEN BEGIN EXPRESSION(FSYS + [RPARENT], X); CASE N OF 0, (* ABS *) 2: (* SQR *) BEGIN TS := [INTS, REALS]; TAB[I].TYP := X.TYP; IF X.TYP = REALS THEN N := N + 1 END (*0*); 4, (* ODD *) 5: (* CHR *) TS := [INTS]; 6: (* ORD *) TS := [INTS, BOOLS, CHARS]; 7, (* SUCC *) 8: (* PRED *) TS := [CHARS]; 9, (* ROUND *) 10, (* TRUNC *) 11, (* SIN *) 12, (* CO S *) 13, 14, 15, 16: BEGIN TS := [INTS, REALS]; IF X.TYP = INTS THEN EMIT1(26, 0) END (*9*) END (*CASE*); IF X.TYP IN TS THEN EMIT1(8, N) ELSE IF X.TYP <> NOTYP THEN ERROR(48); END (*IF*) ELSE BEGIN (* N IN [17,18] *) IF SY <> IDENT THEN ERROR(2) ELSE IF ID <> 'INPUT ' THEN ERROR(0) ELSE INSYMBOL; EMIT1(8, N) END (*ELSE*); X.TYP := TAB[I].TYP; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END (*STANDFCT*); BEGIN (* FACTOR *) X.TYP := NOTYP; X.IREF := 0; TEST(FACBEGSYS, FSYS, 58); WHILE SY IN FACBEGSYS DO BEGIN IF SY = IDENT THEN BEGIN I := LOC(ID); INSYMBOL; WITH TAB[I] DO CASE OBJ OF KONSTANT: BEGIN X.TYP := TYP; X.IREF := 0; IF X.TYP = REALS THEN IF X.TYP = REALS THEN EMIT1(25, ADR) ELSE EMIT1(24, ADR) END (*KONSTANT*); VARIABLE: BEGIN X.TYP := TYP; X.IREF := IREF; IF SY IN [LBRACK, LPARENT, PERIOD] THEN BEGIN IF NORMAL THEN F := 0 ELSE F := 1; EMIT2(F, LEV, ADR); SELECTOR(FSYS, X); IF X.TYP IN STANTYPS THEN EMIT(34) END (*IF*) ELSE BEGIN IF X.TYP IN STANTYPS THEN IF NORMAL THEN F := 1 ELSE F := 2 ELSE IF NORMAL THEN F := 0 ELSE F := 1; EMIT2(F, LEV, ADR) END (*ELSE*) END (*VARIABLE*); TYPE1, PROZEDURE: ERROR(44); FUNKTION: BEGIN X.TYP := TYP; IF LEV <> 0 THEN CALL(FSYS, I) ELSE STANDFCT(ADR) END (*FUNKTION*) END (*CASE*) END (*IF*) ELSE IF SY IN [CHARCON, INTCON, REALCON] THEN BEGIN IF SY = REALCON THEN BEGIN X.TYP := REALS; ENTERREAL(RNUM); EMIT1(25, C1) END (*IF*) ELSE BEGIN IF SY = CHARCON THEN X.TYP := CHARS ELSE X.TYP := INTS; EMIT1(24, INUM) END (*ELSE*); X.IREF := 0; INSYMBOL END (*IF*) ELSE IF SY = LPARENT THEN BEGIN INSYMBOL; EXPRESSION(FSYS + [RPARENT], X); IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END (*IF*) ELSE IF SY = NOTSY THEN BEGIN INSYMBOL; FACTOR(FSYS, X); IF X.TYP = BOOLS THEN EMIT(35) ELSE IF X.TYP <> NOTYP THEN ERROR(32) END (*IF*); TEST(FSYS, FACBEGSYS, 6) END (*WHILE*) END (*FACTOR*); BEGIN (*TERM*) FACTOR(FSYS + [TIMES, RDIV, IDIV, IMOD, ANDSY], X); WHILE SY IN [TIMES, RDIV, IDIV, IMOD, ANDSY] DO BEGIN OP := SY; INSYMBOL; FACTOR(FSYS + [TIMES, RDIV, IDIV, IMOD, ANDSY], Y); IF OP = TIMES THEN BEGIN X.TYP := RESULTTYPE(X.TYP, Y.TYP); CASE X.TYP OF NOTYP:; INTS: EMIT(57); REALS: EMIT(60) END (*CASE*) END (*IF*) ELSE IF OP = RDIV THEN BEGIN IF X.TYP = INTS THEN BEGIN EMIT1(26, 1); X.TYP := REALS END (*IF*); IF Y.TYP = INTS THEN BEGIN EMIT1(26, 0); Y.TYP := REALS END (*IF*); IF (X.TYP = REALS) AND (Y.TYP = REALS) THEN EMIT(61) ELSE BEGIN IF (X.TYP <> NOTYP) AND (Y.TYP <> NOTYP) THEN ERROR(33); X.TYP := NOTYP END (*ELSE*) END (*IF*) ELSE IF OP = ANDSY THEN BEGIN IF (X.TYP = BOOLS) AND (Y.TYP = BOOLS) THEN EMIT(56) ELSE BEGIN IF (X.TYP <> NOTYP) AND (Y.TYP <> NOTYP) THEN ERROR(32); X.TYP := NOTYP END (*ELSE*) END (*IF*) ELSE BEGIN (* OP IN IDIV,IMOD *) IF (X.TYP = INTS) AND (Y.TYP = INTS) THEN IF OP = IDIV THEN EMIT(58) ELSE EMIT(59) ELSE BEGIN IF (X.TYP <> NOTYP) AND (Y.TYP <> NOTYP) THEN ERROR(34); X.TYP := NOTYP END (*ELSE*) END (*ELSE*) END (*WHILE*) END (*TERM*); BEGIN (* SIMPLEEXPRESSION *) IF SY IN [PLUS, MINUS] THEN BEGIN OP := SY; INSYMBOL; TERM(FSYS + [PLUS, MINUS], X); IF X.TYP > REALS THEN ERROR(33) ELSE IF OP = MINUS THEN EMIT(36) END (*IF*) ELSE TERM(FSYS + [PLUS, MINUS, ORSY], X); WHILE SY IN [PLUS, MINUS, ORSY] DO BEGIN OP := SY; INSYMBOL; TERM(FSYS + [PLUS, MINUS, ORSY], Y); IF OP = ORSY THEN BEGIN IF (X.TYP = BOOLS) AND (Y.TYP = BOOLS) THEN EMIT(51) ELSE BEGIN IF (X.TYP <> NOTYP) AND (Y.TYP <> NOTYP) THEN ERROR(32); X.TYP := NOTYP END (*ELSE*) END (*IF*) ELSE BEGIN X.TYP := RESULTTYPE(X.TYP, Y.TYP); CASE X.TYP OF NOTYP:; INTS: IF OP = PLUS THEN EMIT(52) ELSE EMIT(53); REALS: IF OP = PLUS THEN EMIT(54) ELSE EMIT(55) END (*CASE*) END (*ELSE*) END (*WHILE*) END (*SIMPLEEXPRESSION*); BEGIN (* EXPRESSION *) SIMPLEEXPRESSION(FSYS + [EQL, NEQ, LSS, LEQ, GTR, GEQ], X); IF SY IN [EQL, NEQ, LSS, LEQ, GTR, GEQ] THEN BEGIN OP := SY; INSYMBOL; SIMPLEEXPRESSION(FSYS, Y); IF (X.TYP IN [NOTYP, INTS, BOOLS, CHARS]) AND (X.TYP = Y.TYP) THEN CASE OP OF EQL: EMIT(45); NEQ: EMIT(46); LSS: EMIT(47); LEQ: EMIT(48); GTR: EMIT(49); GEQ: EMIT(50) END (*CASE*) ELSE BEGIN IF X.TYP = INTS THEN BEGIN X.TYP := REALS; EMIT1(26, 1) END (*IF*) ELSE IF Y.TYP = INTS THEN BEGIN Y.TYP := REALS; EMIT1(26, 0) END (*IF*); IF (X.TYP = REALS) AND (Y.TYP = REALS) THEN CASE OP OF EQL: EMIT(39); NEQ: EMIT(40); LSS: EMIT(41); LEQ: EMIT(42); GTR: EMIT(43); GEQ: EMIT(44) END (*CASE*) ELSE ERROR(35) END (*ELSE*); X.TYP := BOOLS END (*IF*) END (*EXPRESSION*); PROCEDURE ASSIGNMENT(LV, AD: INTEGER); VAR X, Y: ITEM; F: INTEGER; (* TAB[I].OBJ IN [VARIABLE,PROZEDURE]*) BEGIN X.TYP := TAB[I].TYP; X.IREF := TAB[I].IREF; IF TAB[I].NORMAL THEN F := 0 ELSE F := 1; EMIT2(F, LV, AD); IF SY IN [LBRACK, LPARENT, PERIOD] THEN SELECTOR([BECOMES, EQL] + FSYS, X); IF SY = BECOMES THEN INSYMBOL ELSE BEGIN ERROR(51); IF SY = EQL THEN INSYMBOL END (*ELSE*); EXPRESSION(FSYS, Y); IF X.TYP = Y.TYP THEN IF X.TYP IN STANTYPS THEN EMIT(38) ELSE IF X.IREF <> Y.IREF THEN ERROR(46) ELSE IF X.TYP = ARRAYS THEN EMIT1(23, ATAB[X.IREF].SIZE) ELSE EMIT1(23, BTAB[X.IREF].VSIZE) ELSE IF (X.TYP = REALS) AND (Y.TYP = INTS) THEN BEGIN EMIT1(26, 0); EMIT(38) END (*IF*) ELSE IF (X.TYP <> NOTYP) AND (Y.TYP <> NOTYP) THEN ERROR(46) END (*ASSIGNMENT*); PROCEDURE COMPOUNDSTATEMENT; BEGIN INSYMBOL; WHILE SY IN [SEMICOLON] + STATBEGSYS DO BEGIN IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14); STATEMENT([SEMICOLON, ENDSY] + FSYS) END (*WHILE*); IF SY = ENDSY THEN INSYMBOL ELSE ERROR(57) END (*COMPOUNDSTATEMENT*); PROCEDURE IFSTATEMENT; VAR X: ITEM; LC1, LC2: INTEGER; BEGIN INSYMBOL; EXPRESSION(FSYS + [THENSY, DOSY], X); IF NOT (X.TYP IN [BOOLS, NOTYP]) THEN ERROR(17); LC1 := LC; EMIT(11); (* JMPC *) IF SY = THENSY THEN INSYMBOL ELSE BEGIN ERROR(52); IF SY = DOSY THEN INSYMBOL END (*ELSE*); STATEMENT(FSYS + [ELSESY]); IF SY = ELSESY THEN BEGIN INSYMBOL; LC2 := LC; EMIT(10); CODE[LC1].Y := LC; STATEMENT(FSYS); CODE[LC2].Y := LC END (*IF*) ELSE CODE[LC1].Y := LC END (*IFSTATEMENT*); PROCEDURE CASESTATEMENT; VAR X: ITEM; I, J, K, LC1: INTEGER; CASETAB: ARRAY [1.. CSMAX] OF PACKED RECORD VAL, LC: INDEX END; EXITTAB: ARRAY [1 .. CSMAX] OF INTEGER; PROCEDURE CASELABEL; VAR LAB: CONREC; K: INTEGER; BEGIN CONSTANT(FSYS + [COMMA, COLON], LAB); IF LAB.TP <> X.TYP THEN ERROR(47) ELSE IF I = CSMAX THEN FATAL(6) ELSE BEGIN I := I + 1; K := 0; CASETAB[I].VAL := LAB.I; CASETAB[I].LC := LC; REPEAT K := K + 1; UNTIL CASETAB[K].VAL = LAB.I; IF K < I THEN ERROR(1); (* MULTIPLE DEF *) END (*ELSE*) END (*CASELABEL*); PROCEDURE ONECASE; BEGIN IF SY IN CONSTBEGSYS THEN BEGIN CASELABEL; WHILE SY = COMMA DO BEGIN INSYMBOL; CASELABEL END (*WHILE*); IF SY = COLON THEN INSYMBOL ELSE ERROR(5); STATEMENT([SEMICOLON, ENDSY] + FSYS); J := J + 1; EXITTAB[J] := LC; EMIT(10) END (*IF*) END (*ONECASE*); BEGIN (*CASESTATEMENT*) INSYMBOL; I := 0; J := 0; EXPRESSION(FSYS + [OFSY, COMMA, COLON], X); IF NOT (X.TYP IN [INTS, BOOLS, CHARS, NOTYP]) THEN ERROR(23); LC1 := LC; EMIT(12); (* JMPX *) IF SY = OFSY THEN INSYMBOL ELSE ERROR(8); ONECASE; WHILE SY = SEMICOLON DO BEGIN INSYMBOL; ONECASE END (*WHILE*); CODE[LC1].Y := LC; FOR K := 1 TO I DO BEGIN EMIT1(13, CASETAB[K].VAL); EMIT1(13, CASETAB[K].LC) END (*FOR*); EMIT1(10, 0); FOR K := 1 TO J DO CODE[EXITTAB[K]].Y := LC; IF SY = ENDSY THEN INSYMBOL ELSE ERROR(57) END (*CASESTATEMENT*); PROCEDURE REPEATSTATEMENT; VAR X: ITEM; LC1: INTEGER; BEGIN LC1 := LC; INSYMBOL; STATEMENT([SEMICOLON, UNTILSY] + FSYS); WHILE SY IN [SEMICOLON] + STATBEGSYS DO BEGIN IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14); STATEMENT([SEMICOLON, UNTILSY] + FSYS) END (*WHILE*); IF SY = UNTILSY THEN BEGIN INSYMBOL; EXPRESSION(FSYS, X); IF NOT (X.TYP IN [BOOLS, NOTYP]) THEN ERROR(17); EMIT1(11, LC1) END (*IF*) ELSE ERROR(53) END (*REPEATSTATEMENT*); PROCEDURE WHILESTATEMENT; VAR X: ITEM; LC1, LC2: INTEGER; BEGIN INSYMBOL; LC1 := LC; EXPRESSION(FSYS + [DOSY], X); IF NOT (X.TYP IN [BOOLS, NOTYP]) THEN ERROR(17); LC2 := LC; EMIT(11); IF SY = DOSY THEN INSYMBOL ELSE ERROR(54); STATEMENT(FSYS); EMIT1(10, LC1); CODE[LC1].Y := LC END (*WHILESTATEMENT*); PROCEDURE FORSTATEMENT; VAR CVT: TYPES; X: ITEM; I, F, LC1, LC2: INTEGER; BEGIN INSYMBOL; IF SY = IDENT THEN BEGIN I := LOC(ID); INSYMBOL; IF I = 0 THEN CVT := INTS ELSE IF TAB[I].OBJ = VARIABLE THEN BEGIN CVT := TAB[I].TYP; EMIT2(0, TAB[I].LEV, TAB[I].ADR); IF NOT (CVT IN [NOTYP, INTS, BOOLS, CHARS]) THEN ERROR(18) END (*IF*) ELSE BEGIN ERROR(37); CVT := INTS END (*ELSE*) END (*IF*) ELSE SKIP([BECOMES, TOSY, DOWNTOSY, DOSY] + FSYS, 2); IF SY = BECOMES THEN BEGIN INSYMBOL; EXPRESSION([TOSY, DOWNTOSY, DOSY] + FSYS, X); IF X.TYP <> CVT THEN ERROR(19); END (*IF*) ELSE SKIP([TOSY, DOWNTOSY, DOSY] + FSYS, 51); F := 14; IF SY IN [TOSY, DOWNTOSY] THEN BEGIN IF SY = DOWNTOSY THEN F := 16; INSYMBOL; EXPRESSION([DOSY] + FSYS, X); IF X.TYP <> CVT THEN ERROR(19) END (*IF*) ELSE SKIP([DOSY] + FSYS, 55); LC1 := LC; EMIT(F); IF SY = DOSY THEN INSYMBOL ELSE ERROR(54); LC2 := LC; STATEMENT(FSYS); EMIT1(F + 1, LC2); CODE[LC1].Y := LC END (*FORSTATEMENT*); PROCEDURE STANDPROC(N: INTEGER); VAR I, F: INTEGER; X, Y: ITEM; BEGIN CASE N OF 1, 2: BEGIN (* READ *) IF NOT IFLAG THEN BEGIN ERROR(20); IFLAG := TRUE END (*IF*); IF SY = LPARENT THEN BEGIN REPEAT INSYMBOL; IF SY <> IDENT THEN ERROR(2) ELSE BEGIN I := LOC(ID); INSYMBOL; IF I <> 0 THEN IF TAB[I].OBJ <> VARIABLE THEN ERROR(37) ELSE BEGIN X.TYP := TAB[I].TYP; X.IREF := TAB[I].IREF; IF TAB[I].NORMAL THEN F := 0 ELSE F := 1; EMIT2(F, TAB[I].LEV, TAB[I].ADR); IF SY IN [LBRACK, LPARENT, PERIOD] THEN SELECTOR(FSYS + [COMMA, RPARENT], X); IF X.TYP IN [INTS, REALS, CHARS, NOTYP] THEN EMIT1(27, ORD(X.TYP)) ELSE ERROR(40) END (*ELSE*) END (*ELSE*); TEST([COMMA, RPARENT], FSYS, 6) UNTIL SY <> COMMA; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END (*IF*); IF N = 2 THEN EMIT(62) END (*1*); 3, 4: BEGIN (*WRITE*) IF SY = LPARENT THEN BEGIN REPEAT INSYMBOL; IF SY = STRING THEN BEGIN EMIT1(24, SLENG); EMIT1(28, INUM); INSYMBOL END (*IF*) ELSE BEGIN EXPRESSION(FSYS + [COMMA, COLON, RPARENT], X); IF NOT (X.TYP IN STANTYPS) THEN ERROR(41); IF SY = COLON THEN BEGIN INSYMBOL; EXPRESSION(FSYS + [COMMA, COLON, RPARENT], Y); IF Y.TYP <> INTS THEN ERROR(43); IF SY = COLON THEN BEGIN IF X.TYP <> REALS THEN ERROR(42); INSYMBOL; EXPRESSION(FSYS + [COMMA, RPARENT], Y); IF Y.TYP <> INTS THEN ERROR(43); EMIT(37) END (*IF*) ELSE EMIT1(30, ORD(X.TYP)) END (*IF*) ELSE EMIT1(29, ORD(X.TYP)) END (*ELSE*) UNTIL SY <> COMMA; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END (*IF*); IF N = 4 THEN EMIT(63) END (*3*) END (*CASE*) END (*STANDPROC*); BEGIN (* STATEMENT *) IF SY IN STATBEGSYS + [IDENT] THEN CASE SY OF IDENT: BEGIN I := LOC(ID); INSYMBOL; IF I <> 0 THEN CASE TAB[I].OBJ OF KONSTANT, TYPE1: ERROR(45); VARIABLE: ASSIGNMENT(TAB[I].LEV, TAB[I].ADR); PROZEDURE: IF TAB[I].LEV <> 0 THEN CALL(FSYS, I) ELSE STANDPROC(TAB[I].ADR); FUNKTION: IF TAB[I].IREF = DISPLAY[LEVEL] THEN ASSIGNMENT(TAB[I].LEV + 1, 0) ELSE ERROR(45) END (*CASE*) END (*IDENT*); BEGINSY: COMPOUNDSTATEMENT; IFSY: IFSTATEMENT; CASESY: CASESTATEMENT; WHILESY: WHILESTATEMENT; REPEATSY: REPEATSTATEMENT; FORSY: FORSTATEMENT END (*CASE*); TEST(FSYS, [], 14) END (*STATEMENT*); BEGIN (*BLOCK*) DX := 5; PRT := T; IF LEVEL > LMAX THEN FATAL(5); TEST([LPARENT, COLON, SEMICOLON], FSYS, 7); ENTERBLOCK; DISPLAY[LEVEL] := B; PRB := B; TAB[PRT].TYP := NOTYP; TAB[PRT].IREF := PRB; IF SY = LPARENT THEN PARAMETERLIST; BTAB[PRB].LASTPAR := T; BTAB[PRB].PSIZE := DX; IF ISFUN THEN IF SY = COLON THEN BEGIN INSYMBOL (* FUNCTION TYPE *); IF SY = IDENT THEN BEGIN X := LOC(ID); INSYMBOL; IF X <> 0 THEN IF TAB[X].OBJ <> TYPE1 THEN ERROR(29) ELSE IF TAB[X].TYP IN STANTYPS THEN TAB[PRT].TYP := TAB[X].TYP ELSE ERROR(15) END (*IF*) ELSE SKIP([SEMICOLON] + FSYS, 2) END (*IF*) ELSE ERROR(5); IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14); REPEAT IF SY = CONSTSY THEN CONSTANTDECLARATION; IF SY = TYPESY THEN TYPEDECLARATION; IF SY = VARSY THEN VARIABLEDECLARATION; BTAB[PRB].VSIZE := DX; WHILE SY IN [PROCEDURESY, FUNCTIONSY] DO PROCDECLARATION; TEST([BEGINSY], BLOCKBEGSYS + STATBEGSYS, 56) UNTIL SY IN STATBEGSYS; TAB[PRT].ADR := LC; INSYMBOL; STATEMENT([SEMICOLON, ENDSY] + FSYS); WHILE SY IN [SEMICOLON] + STATBEGSYS DO BEGIN IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14); STATEMENT([SEMICOLON, ENDSY] + FSYS) END (*WHILE*); IF SY = ENDSY THEN INSYMBOL ELSE ERROR(57); TEST(FSYS + [PERIOD], [], 6) END (*BLOCK*); PROCEDURE INTERPRET; VAR IR: ORDER; PC: INTEGER; PS: (RUN, FIN, CASCHK, DIVCHK, INXCHK, STKCHK, LINCHK, LNGCHK, REDCHK); T: INTEGER; B: INTEGER; LNCNT, OCNT, BLKCNT, CHRCNT, REMOVE: INTEGER; H1, H2, H3, H4: INTEGER; FLD: ARRAY [1..4] OF INTEGER; DISPLAY: ARRAY [1.. LMAX] OF INTEGER; S: ARRAY [1.. STACKSIZE] OF RECORD CASE TYPES OF INTS: ( I: INTEGER); REALS: ( R: REAL); BOOLS: ( B: BOOLEAN); CHARS: ( C: CHAR) END; BEGIN (* INTERPRET *) S[1].I := 0; S[2].I := 0; S[3].I := - 1; S[4].I := BTAB[1].LAST; B := 0; DISPLAY[1] := 0; T := BTAB[2].VSIZE - 1; PC := TAB[S[4].I].ADR; PS := RUN; LNCNT := 0; OCNT := 0; CHRCNT := 0; FLD[1] := 10; FLD[2] := 22; FLD[3] := 10; FLD[4] := 1; REPEAT IR := CODE[PC]; PC := PC + 1; OCNT := OCNT + 1; CASE IR.F OF 0: BEGIN (* LOAD ADDRESS *) T := T + 1; IF T > STACKSIZE THEN PS := STKCHK ELSE S[T].I := DISPLAY[IR.X] + IR.Y END (*0*); 1: BEGIN (* LOAD VALUE *) T := T + 1; IF T > STACKSIZE THEN PS := STKCHK ELSE S[T] := S[DISPLAY[IR.X] + IR.Y] END (*1*); 2: BEGIN (* LOAD INDIRECT *) T := T + 1; IF T > STACKSIZE THEN PS := STKCHK ELSE S[T] := S[S[DISPLAY[IR.X] + IR.Y].I] END (*2*); 3: BEGIN (* UPDATE DISPLAY *) H1 := IR.Y; H2 := IR.X; H3 := B; REPEAT DISPLAY[H1] := H3; H1 := H1 - 1; H3 := S[H3 + 2].I UNTIL H1 = H2 END (*3*); 8: CASE IR.Y OF 0: S[T].I := ABS(S[T].I); 1: S[T].R := ABS(S[T].R); 2: S[T].I := SQR(S[T].I); 3: S[T].R := SQR(S[T].R); 4: S[T].B := ODD(S[T].I); 5: BEGIN (* S[T].C := CHR(S[T].I); *) IF (S[T].I < 0) OR (S[T].I > 63) THEN PS := INXCHK END (*5*); 6: (* S[T].I:=ORD(S[T].C) *); 7: S[T].C := SUCC(S[T].C); 8: S[T].C := PRED(S[T].C); 9: S[T].I := ROUND(S[T].R); 10: S[T].I := TRUNC(S[T].R); 11: S[T].R := SIN(S[T].R); 12: S[T].R := COS(S[T].R); 13: S[T].R := EXP(S[T].R); 14: S[T].R := LN(S[T].R); 15: S[T].R := SQRT(S[T].R); 16: S[T].R := ARCTAN(S[T].R); 17: BEGIN T := T + 1; IF T > STACKSIZE THEN PS := STKCHK ELSE S[T].B := EOF(INPUT) END (*17*); 18: BEGIN T := T + 1; IF T > STACKSIZE THEN PS := STKCHK ELSE S[T].B := EOLN(INPUT) END (*18*); END (*CASE*); 9: S[T].I := S[T].I + IR.Y (* OFFSET *); 10: PC := IR.Y (* JUMP *); 11: BEGIN (* CONDITIONAL JUMP *) IF NOT S[T].B THEN PC := IR.Y; T := T - 1 END (*11*); 12: BEGIN (* SWITCH *) H1 := S[T].I; T := T - 1; H2 := IR.Y; H3 := 0; REPEAT IF CODE[H2].F <> 13 THEN BEGIN H3 := 1; PS := CASCHK END (*IF*) ELSE IF CODE[H2].Y = H1 THEN BEGIN H3 := 1; PC := CODE[H2 + 1].Y END (*IF*) ELSE H2 := H2 + 2 UNTIL H3 <> 0; END (*12*); 14: BEGIN (* FOR1UP*) H1 := S[T - 1].I; IF H1 <= S[T].I THEN S[S[T - 2].I].I := H1 ELSE BEGIN T := T - 3; PC := IR.Y END (*ELSE*) END (*14*); 15: BEGIN (* FOR2UP *) H2 := S[T - 2].I; H1 := S[H2].I + 1; IF H1 <= S[T].I THEN BEGIN S[H2].I := H1; PC := IR.Y END (*IF*) ELSE T := T - 3; END (*15*); 16: BEGIN (*FOR1DOWN*) H1 := S[T - 1].I; IF H1 >= S[T].I THEN S[S[T - 2].I].I := H1 ELSE BEGIN PC := IR.Y; T := T - 3; END (*ELSE*) END (*16*); 17: BEGIN (*FOR2DOWN*) H2 := S[T - 2].I; H1 := S[H2].I - 1; IF H1 >= S[T].I THEN BEGIN S[H2].I := H1; PC := IR.Y END (*IF*) ELSE T := T - 3 END (*17*); 18: BEGIN (* MARCK STACK*) H1 := BTAB[TAB[IR.Y].IREF].VSIZE; IF T + H1 > STACKSIZE THEN PS := STKCHK ELSE BEGIN T := T + 5; S[T - 1].I := H1 - 1; S[T].I := IR.Y END (*ELSE*) END (*18*); 19: BEGIN (* CALL *) H1 := T - IR.Y (*H1 POINTS TO BASE *); H2 := S[H1 + 4].I (*H2 POINTS TO TAB *); H3 := TAB[H2].LEV; DISPLAY[H3 + 1] := H1; H4 := S[H1 + 3].I + H1; S[H1 + 1].I := PC; S[H1 + 2].I := DISPLAY[H3]; S[H1 + 3].I := B; FOR H3 := T + 1 TO H4 DO S[H3].I := 0; B := H1; T := H4; PC := TAB[H2].ADR END (*19*); 20: BEGIN (* INDEX1 *) H1 := IR.Y (* H1 POINTS TO ATAB *); H2 := ATAB[H1].LOW; H3 := S[T].I; IF H3 < H2 THEN PS := INXCHK ELSE IF H3 > ATAB[H1].HIGH THEN PS := INXCHK ELSE BEGIN T := T - 1; S[T].I := S[T].I + (H3 - H2) END (*ELSE*) END (*20*); 21: BEGIN (* INDEX *) H1 := IR.Y (* H1 POINTS TO ATAB *); H2 := ATAB[H1].LOW; H3 := S[T].I; IF H3 < H2 THEN PS := INXCHK ELSE IF H3 > ATAB[H1].HIGH THEN PS := INXCHK ELSE BEGIN T := T - 1; S[T].I := S[T].I + (H3 - H2) * ATAB[H1].ELSIZE END (*ELSE*) END (*21*); 22: BEGIN (* LOAD BLOCK *) H1 := S[T].I; T := T - 1; H2 := IR.Y + T; IF H2 > STACKSIZE THEN PS := STKCHK ELSE WHILE T < H2 DO BEGIN T := T + 1; S[T] := S[H1]; H1 := H1 + 1 END (*WHILE*) END (*22*); 23: BEGIN (* COPY BLOCK *) H1 := S[T - 1].I; H2 := S[T].I; H3 := H1 + IR.Y; WHILE H1 < H3 DO BEGIN S[H1] := S[H2]; H1 := H1 + 1; H2 := H2 + 1 END (*WHILE*); T := T - 2 END (*23*); 24: BEGIN (* LITERAL *) T := T - 1; IF T > STACKSIZE THEN PS := STKCHK ELSE S[T].I := IR.Y END (*24*); 25: BEGIN (* LOAD REAL *) T := T - 1; IF T > STACKSIZE THEN PS := STKCHK ELSE S[T].R := RCONST[IR.Y] END (*25*); 26: BEGIN (* FLOAT *) H1 := T - IR.Y; S[H1].R := S[H1].I; END (*26*); 27: BEGIN (* READ *) IF EOF(INPUT) THEN PS := REDCHK ELSE CASE IR.Y OF 1: READ(S[S[T].I].I); 2: READ(S[S[T].I].R); 3: READ(S[S[T].I].C); END (*CASE*); T := T - 1 END (*27*); 28: BEGIN (* WRITE STRING *) H1 := S[T].I; H2 := IR.Y; T := T - 1; CHRCNT := CHRCNT + H1; IF CHRCNT > LINELENG THEN PS := LNGCHK; REPEAT WRITE(STAB[H2]); H1 := H1 - 1; H2 := H2 + 1 UNTIL H1 = 0 END (*28*); 29: BEGIN (* WRITE1 *) CHRCNT := CHRCNT + FLD[IR.Y]; IF CHRCNT > LINELENG THEN PS := LNGCHK ELSE CASE IR.Y OF 1: WRITE(S[T].I: FLD[1]); 2: WRITE(S[T].R: FLD[2]); 3: WRITE(S[T].B: FLD[3]); 4: WRITE(S[T].C) END (*CASE*); T := T - 1 END (*29*); 30: BEGIN (* WRITE2 *) CHRCNT := CHRCNT + S[T].I; IF CHRCNT > LINELENG THEN PS := LNGCHK ELSE CASE IR.Y OF 1: WRITE(S[T - 1].I: S[T].I); 2: WRITE(S[T - 1].R: S[T].I); 3: WRITE(S[T - 1].B: S[T].I); 4: WRITE(S[T - 1].C: S[T].I); END (*CASE*); T := T - 2 END (*30*); 31: PS := FIN; 32: BEGIN (* EXIT PROCEDURE *) T := B - 1; PC := S[B + 1].I; B := S[B + 3].I END (*32*); 33: BEGIN (* EXIT FUNCTION *) T := B; PC := S[B + 1].I; B := S[B + 3].I END (*33*); 34: S[T] := S[S[T].I]; 35: S[T].B := NOT S[T].B; 36: S[T].I := - S[T].I; 37: BEGIN CHRCNT := CHRCNT + S[T - 1].I; IF CHRCNT > LINELENG THEN PS := LNGCHK ELSE WRITE(S[T - 2].R: S[T - 1].I: S[T].I); T := T - 3 END (*37*); 38: BEGIN (* STORE *) S[S[T - 1].I] := S[T]; T := T - 2 END (*38*); 39: BEGIN T := T - 1; S[T].B := S[T].R = S[T + 1].R END (*39*); 40: BEGIN T := T - 1; S[T].B := S[T].R <> S[T + 1].R END (*40*); 41: BEGIN T := T - 1; S[T].B := S[T].R < S[T + 1].R END (*41*); 42: BEGIN T := T - 1; S[T].B := S[T].R <= S[T + 1].R END (*42*); 43: BEGIN T := T - 1; S[T].B := S[T].R > S[T + 1].R END (*43*); 44: BEGIN T := T - 1; S[T].B := S[T].R >= S[T + 1].R END (*44*); 45: BEGIN T := T - 1; S[T].B := S[T].I = S[T + 1].I END (*45*); 46: BEGIN T := T - 1; S[T].B := S[T].I <> S[T + 1].I END (*46*); 47: BEGIN T := T - 1; S[T].B := S[T].I < S[T + 1].I END (*47*); 48: BEGIN T := T - 1; S[T].B := S[T].I <= S[T + 1].I END (*48*); 49: BEGIN T := T - 1; S[T].B := S[T].I > S[T + 1].I END (*49*); 50: BEGIN T := T - 1; S[T].B := S[T].I >= S[T + 1].I END (*50*); 51: BEGIN T := T - 1; S[T].B := S[T].B OR S[T + 1].B END (*51*); 52: BEGIN T := T - 1; S[T].I := S[T].I + S[T + 1].I END (*52*); 53: BEGIN T := T - 1; S[T].I := S[T].I - S[T + 1].I END (*53*); 54: BEGIN T := T - 1; S[T].R := S[T].R + S[T + 1].R END (*54*); 55: BEGIN T := T - 1; S[T].R := S[T].R - S[T + 1].R END (*55*); 56: BEGIN T := T - 1; S[T].B := S[T].B AND S[T + 1].B END (*56*); 57: BEGIN T := T - 1; S[T].I := S[T].I * S[T + 1].I END (*57*); 58: BEGIN T := T - 1; IF S[T + 1].I = 0 THEN PS := DIVCHK ELSE S[T].I := S[T].I DIV S[T + 1].I END (*58*); 59: BEGIN T := T - 1; IF S[T + 1].I = 0 THEN PS := DIVCHK ELSE S[T].I := S[T].I MOD S[T + 1].I END (*59*); 60: BEGIN T := T - 1; S[T].R := S[T].R * S[T + 1].R END (*60*); 61: BEGIN T := T - 1; S[T].R := S[T].R / S[T + 1].R END (*61*); 62: IF EOF(INPUT) THEN PS := REDCHK ELSE READLN; 63: BEGIN WRITELN; LNCNT := LNCNT + 1; CHRCNT := 0; IF LNCNT > LINELIMIT THEN PS := LINCHK END (*63*) END (* CASE *); UNTIL PS <> RUN; IF PS <> FIN THEN BEGIN WRITELN; WRITE('0HALT AT ', PC: 5, ' BECAUSE OF '); CASE PS OF CASCHK: WRITELN('UNDEFINED CASE'); DIVCHK: WRITELN('DIVISION BY 0'); INXCHK: WRITELN('STORAGE OVERFLOW'); LINCHK: WRITELN('TOO MUCH OUTPUT'); LNGCHK: WRITELN('LINE TOO LONG'); REDCHK: WRITELN('READING PAST END OF FILE'); END (*CASE*); H1 := B; BLKCNT := 10 (* POST MORTEM DUMP *); REPEAT WRITELN; BLKCNT := BLKCNT - 1; IF BLKCNT = 0 THEN H1 := 0; H2 := S[H1 + 4].I; IF H1 <> 0 THEN WRITELN(' ', TAB[H2].NAME, ' CALLED AT', S[H1 + 1].I: 5); H2 := BTAB[TAB[H2].IREF].LAST; WHILE H2 <> 0 DO WITH TAB[H2] DO BEGIN IF OBJ = VARIABLE THEN IF TYP IN STANTYPS THEN BEGIN WRITE(' ', NAME, ' = '); IF NORMAL THEN H3 := H1 + ADR ELSE H3 := S[H1 + ADR].I; CASE TYP OF INTS: WRITELN(S[H3].I); REALS: WRITELN(S[H3].R); BOOLS: WRITELN(S[H3].B); CHARS: WRITELN(S[H3].C); END (*CASE*) END (*IF*); H2 := LINK END (*WITH*); H1 := S[H1 + 3].I UNTIL H1 < 0; END (*IF*); WRITELN; WRITELN(OCNT, ' STEPS') END (*INTERPRET*); BEGIN (* MAIN PROGRAM *) WRITELN; KEY[1] := 'AND '; KEY[2] := 'ARRAY '; KEY[3] := 'BEGIN '; KEY[4] := 'CASE '; KEY[5] := 'CONST '; KEY[6] := 'DIV '; KEY[7] := 'DOWNTO '; KEY[8] := 'DO '; KEY[9] := 'ELSE '; KEY[10] := 'END '; KEY[11] := 'FOR '; KEY[12] := 'FUNCTION '; KEY[13] := 'IF '; KEY[14] := 'MOD '; KEY[15] := 'NOT '; KEY[16] := 'OF '; KEY[17] := 'OR '; KEY[18] := 'PROCEDURE '; KEY[19] := 'PROGRAM '; KEY[20] := 'RECORD '; KEY[21] := 'REPEAT '; KEY[22] := 'THEN '; KEY[23] := 'TO '; KEY[24] := 'TYPE '; KEY[25] := 'UNTIL '; KEY[26] := 'VAR '; KEY[27] := 'WHILE '; KSY[1] := ANDSY; KSY[2] := ARRAYSY; KSY[3] := BEGINSY; KSY[4] := CASESY; KSY[5] := CONSTSY; KSY[6] := IDIV; KSY[7] := DOWNTOSY; KSY[8] := DOSY; KSY[9] := ELSESY; KSY[10] := ENDSY; KSY[11] := FORSY; KSY[12] := FUNCTIONSY; KSY[13] := IFSY; KSY[14] := IMOD; KSY[15] := NOTSY; KSY[16] := OFSY; KSY[17] := ORSY; KSY[18] := PROCEDURESY; KSY[19] := PROGRAMSY; KSY[20] := RECORDSY; KSY[21] := REPEATSY; KSY[22] := THENSY; KSY[23] := TOSY; KSY[24] := TYPESY; KSY[25] := UNTILSY; KSY[26] := VARSY; KSY[27] := WHILESY; SPS['+'] := PLUS; SPS['-'] := MINUS; SPS['*'] := TIMES; SPS['/'] := RDIV; SPS['='] := EQL; SPS['['] := LBRACK; SPS[']'] := RBRACK; SPS['&'] := ANDSY; SPS['('] := LPARENT; SPS[')'] := RPARENT; SPS[','] := COMMA; SPS['#'] := NEQ; SPS[';'] := SEMICOLON; CONSTBEGSYS := [PLUS, MINUS, INTCON, REALCON, CHARCON, IDENT]; TYPEBEGSYS := [IDENT, ARRAYSY, RECORDSY]; BLOCKBEGSYS := [CONSTSY, TYPESY, VARSY, PROCEDURESY, FUNCTIONSY, BEGINSY]; FACBEGSYS := [INTCON, REALCON, CHARCON, IDENT, LPARENT, NOTSY]; STATBEGSYS := [BEGINSY, IFSY, WHILESY, REPEATSY, FORSY, CASESY]; STANTYPS := [NOTYP, INTS, REALS, BOOLS, CHARS]; LC := 0; LL := 0; CC := 0; CH := ' '; ERRPOS := 0; ERRS := []; INSYMBOL; T := - 1; A := 0; B := 1; SX := 0; C2 := 0; DISPLAY[0] := 1; IFLAG := FALSE; OFLAG := FALSE; IF SY <> PROGRAMSY THEN ERROR(3) ELSE BEGIN INSYMBOL; IF SY <> IDENT THEN ERROR(2) ELSE BEGIN PROGNAME := ID; INSYMBOL; IF SY <> LPARENT THEN ERROR(9) ELSE REPEAT INSYMBOL; IF SY <> IDENT THEN ERROR(2) ELSE BEGIN IF ID = 'INPUT ' THEN IFLAG := TRUE ELSE IF ID = 'OUTPUT ' THEN OFLAG := TRUE ELSE ERROR(0); INSYMBOL END (*ELSE*) UNTIL SY <> COMMA; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4); IF NOT OFLAG THEN ERROR(20) END (*ELSE*) END (*ELSE*); ENTER(' ', VARIABLE, NOTYP, 0); ENTER('FALSE ', KONSTANT, BOOLS, 0); ENTER('TRUE ', KONSTANT, BOOLS, 1); ENTER('REAL ', TYPE1, REALS, 1); ENTER('CHAR ', TYPE1, CHARS, 1); ENTER('BOOLEAN ', TYPE1, BOOLS, 1); ENTER('INTEGER ', TYPE1, INTS, 1); ENTER('ABS ', FUNKTION, REALS, 0); ENTER('SQR ', FUNKTION, REALS, 2); ENTER('ODD ', FUNKTION, BOOLS, 4); ENTER('CHR ', FUNKTION, CHARS, 5); ENTER('ORD ', FUNKTION, INTS, 6); ENTER('SUCC ', FUNKTION, CHARS, 7); ENTER('PRED ', FUNKTION, CHARS, 8); ENTER('ROUND ', FUNKTION, INTS, 9); ENTER('TRUNC ', FUNKTION, INTS, 10); ENTER('SIN ', FUNKTION, REALS, 11); ENTER('COS ', FUNKTION, REALS, 12); ENTER('EXP ', FUNKTION, REALS, 13); ENTER('LN ', FUNKTION, REALS, 14); ENTER('SQRT ', FUNKTION, REALS, 15); ENTER('ARCTAN ', FUNKTION, REALS, 16); ENTER('EOF ', FUNKTION, BOOLS, 17); ENTER('EOLN ', FUNKTION, BOOLS, 18); ENTER('READ ', PROZEDURE, NOTYP, 1); ENTER('READLN ', PROZEDURE, NOTYP, 2); ENTER('WRITE ', PROZEDURE, NOTYP, 3); ENTER('WRITELN ', PROZEDURE, NOTYP, 4); ENTER(' ', PROZEDURE, NOTYP, 0); WITH BTAB[1] DO BEGIN LAST := T; LASTPAR := 1; PSIZE := 0; VSIZE := 0 END (*WITH*); BLOCK(BLOCKBEGSYS + STATBEGSYS, FALSE, 1); IF SY <> PERIOD THEN ERROR(22); EMIT(31) (* HALT *); IF BTAB[2].VSIZE > STACKSIZE THEN ERROR(49); IF PROGNAME = 'TEST0 ' THEN PRINTTABLES; IF ERRS = [] THEN BEGIN IF IFLAG THEN BEGIN IF EOF(INPUT) THEN WRITELN(' INPUT DATA MISSING') ELSE BEGIN WRITELN(' (EOR) ') (* COPY INPUT DATA *); WHILE NOT EOF(INPUT) DO BEGIN WRITE(' '); WHILE NOT EOLN(INPUT) DO BEGIN READ(CH); WRITE(CH); END (*WHILE*); WRITELN; READ(CH) END (*WHILE*); END (*ELSE*) END (*IF*); WRITELN(' (EOF) '); INTERPRET END (*IF*) ELSE ERRORMSG; 99: END (*PASCALS*).